home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / tex / sortdemo.zip / SHAKE.PAS < prev    next >
Pascal/Delphi Source File  |  1987-09-03  |  3KB  |  120 lines
  1.                                           { K.L. Noell, fhw 03.Sep.87 }
  2.   PROGRAM ShakeSort_Demo (output);
  3.   Const n = 639;            { number of columns :  x-coordinates }
  4.         range = 199;        { actual size :        y-coordinates }
  5.         clear_pixel = 0;
  6.         set_pixel   = 3;
  7.   VAR
  8.         i1: INTEGER;
  9.         num,loops,swaps,aloops,aswaps: REAL;
  10.         D : array [1..n] of INTEGER;
  11.  
  12.  
  13.   PROCEDURE Swap ( VAR x,y: INTEGER );
  14.   VAR
  15.        temp: INTEGER;
  16.  
  17.   BEGIN
  18.        temp := x;
  19.        x := y;
  20.        y := temp;
  21.        swaps := swaps + 1;
  22.   END;  { Swap }
  23.  
  24.  
  25.   PROCEDURE ShakeSort (np: INTEGER) ;
  26.   VAR
  27.      i,j,r,l: 0..n;
  28.  
  29.   BEGIN
  30.      l := 2;
  31.      r := np;
  32.      i := np-1;
  33.  
  34.      REPEAT
  35.         FOR j := r DOWNTO l DO BEGIN     { shake up }
  36.            loops := loops + 1;
  37.            If D[j-1] > D[j] THEN
  38.               BEGIN
  39.               Plot (j,D[j],clear_pixel);
  40.               Plot ((j-1),D[j-1],clear_pixel);
  41.               Swap (D[j],D[j-1]);
  42.               Plot (j,D[j],set_pixel);
  43.               Plot ((j-1),D[j-1],set_pixel);
  44.               i := j;
  45.               END;
  46.         END;
  47.         l := i + 1;
  48.  
  49.         FOR j := l TO r DO BEGIN         { shake down }
  50.            IF D[j-1] > D[j] THEN
  51.               BEGIN
  52.               loops := loops + 1;
  53.               Plot (j,D[j],clear_pixel);
  54.               Plot ((j-1),D[j-1],clear_pixel);
  55.               Swap (D[j],D[j-1]);
  56.               Plot (j,D[j],set_pixel);
  57.               Plot ((j-1),D[j-1],set_pixel);
  58.               i := j;
  59.               END;
  60.         END;
  61.  
  62.         r := i - 1;
  63.      UNTIL l > r;
  64.  
  65.   END;  { ShakeSort }
  66.  
  67.  
  68.  BEGIN  (*********  Main Program  ShakeSort_Demo  *********************)
  69.         HiRes;
  70.         HiResColor (Brown);
  71.         Palette (2);
  72.  
  73.         FOR i1:=1 TO n DO BEGIN
  74.             num := range*RANDOM;
  75.             D[i1] := TRUNC (num);
  76.             Plot (i1,D[i1],set_pixel);
  77.         END;
  78.  
  79.         {Sorting start:}
  80.         loops := 0;
  81.         swaps := 0;
  82.         DELAY (1000);
  83.  
  84.         ShakeSort (n);
  85.  
  86.         aloops := loops;
  87.         aswaps := swaps;
  88.         Writeln ('   Shake Sort a)  Loops,Swaps: ',loops,swaps);
  89.         Writeln;
  90.         Writeln ('b) Press any key to process with an array already sorted,');
  91.         Writeln ('   but in opposite direction.');
  92.  
  93.         REPEAT UNTIL KeyPressed;
  94.  
  95.         Hires;
  96.         HiResColor (Brown);
  97.         Palette (2);
  98.  
  99.         FOR i1:=1 TO n DO BEGIN
  100.             num := (n-i1)/(n/range);
  101.             D[i1] := TRUNC (num);
  102.             Plot (i1,D[i1],set_pixel);
  103.         END;
  104.  
  105.         {Sorting start:}
  106.         loops := 0;
  107.         swaps := 0;
  108.         DELAY (1000);
  109.  
  110.         ShakeSort (n);
  111.  
  112.         Writeln (' Shell Sort a)  Loops,Swaps: ',aloops,aswaps);
  113.         Writeln (' Shell Sort b)  Loops,Swaps: ',loops,swaps);
  114.         Writeln;
  115.         Writeln (' Press any key to exit.');
  116.  
  117.         REPEAT UNTIL KeyPressed;
  118.         TextMode;
  119.  END.   (*********  Main Program  ShakeSort_Demo  *********************)
  120.